home *** CD-ROM | disk | FTP | other *** search
/ The PC-SIG Library 10 / The PC-Sig Library - Shareware for the IBM PC and Compatibles (PC-SIG)(Tenth Edition Disks 1-2804)(1991).iso / PC_SIGCD / 04 / 4 / DISK0442.ZIP / CK.DOC next >
Text File  |  1990-02-12  |  45KB  |  229 lines
  1. COMMA \ PLIPUNCH Y SRCPUNCH Y TITLE RODGERS ANCESTOR PROCESSING
  2. C BUILD, CORRELATE ANCESTORS TREES\\
  3.     \C MAIN PROGRAM%---%>END\\
  4.     \C SUBROUTINES\;
  5. C MAIN PROGRAM%---%>END\\
  6.     \C DECLARATIONS"3\\
  7.     \>IMOM=1\\
  8.     \>IPOP=2\\
  9.     \>ILEFT=3\\
  10.     \>IRIGHT=4\\
  11.     \>CALL INIT(I)\\
  12.     \C READ INPUT DATA AND BUILD LEXICAL AND ANCESTOR TREES\\
  13.     \C SCAN FOR ANCESTOR SETS AND MARK THEM\\
  14.     \C>WRITE(6,999)%(ID(I),(MATRIX(I,J),J=1,4),MARK%(I,1),MARK(I,2),\\
  15.     \C><I=1,IMAX)\\
  16.     \C 999>FORMAT(' ',A8,4I6,2L3)\\
  17.     \C SCAN THE MARK VECTORS AND OUTPUT COUNTS\\
  18.     \>STOP\;
  19. C DECLARATIONS"3\\
  20.     \C UP TO 1200 STRAINS, UP TO 80 GENERATIONS DEPTH\;
  21. C UP TO 1200 STRAINS, UP TO 80 GENERATIONS DEPTH\\
  22.     \>CHARACTER*8 %ID(1200),MOMID,POPID,IDONE,IDTWO,IDS\\
  23.     \C INTEGERS\\
  24.     \>LOGICAL*1 %MARK(1200,20),NEW/.FALSE./\\
  25.     \C CONSTANTS\\
  26.     \>COMMON ID,MATRIX,MARK,IMOM,IPOP,ILEFT,IRIGHT\;
  27. C INTEGERS\\
  28.     \>INTEGER*2 COUNT,HI/1/,I/1/,J/1/,\\
  29.     \><MAX,IMARK,LOC,SP/1/,S(80),RP\\
  30.     \>INTEGER*2 MATRIX(1200,4)\;
  31. C CONSTANTS\\
  32.     \>INTEGER*2 IMOM,IPOP,ILEFT,IRIGHT\;
  33. C READ INPUT DATA AND BUILD LEXICAL AND ANCESTOR TREES\\
  34.     \>READ(5,15)%ID(I),MOMID,POPID\\
  35.     \C DO WHILE ID(I) NOT ASTERISKS%---%90>CONTINUE\\
  36.     \>IMAX=I-1\;
  37. >READ(5,15)%ID(I),MOMID,POPID\\
  38.     \15>FORMAT(3A8)\;
  39. C DO WHILE ID(I) NOT ASTERISKS%---%90>CONTINUE\\
  40.     \25>IF(ID(I).EQ.'********')GOTO 90%---%>GOTO 25\;
  41. 25>IF(ID(I).EQ.'********')GOTO 90%---%>GOTO 25\\
  42.     \>IF(NEW)CALL INIT(I)\\
  43.     \>IDS=MOMID\\
  44.     \>DO 60 J=IMOM,IPOP%---%60>CONTINUE\\
  45.     \>I=I+1\\
  46.     \>READ(5,15)%ID(I),MOMID,POPID\\
  47.     \>CALL FIND%(ID(I),NEW,LOC)%---%85>CONTINUE\;
  48. >DO 60 J=IMOM,IPOP%---%60>CONTINUE\\
  49.     \>CALL FIND%(IDS,NEW,LOC)%---%50>CONTINUE\\
  50.     \>IDS=POPID\;
  51. >CALL FIND%(ID(I),NEW,LOC)%---%85>CONTINUE\\
  52.     \C IF NEW%---%86>CONTINUE\\
  53.     \C ELSE"45\;
  54. C IF NEW%---%86>CONTINUE\\
  55.     \>IF(.NOT.NEW)GOTO 86\\
  56.     \>HI=I\\
  57.     \>CALL PLACEM%(ID(I),I,LOC)\\
  58.     \>GOTO 85\;
  59. C ELSE"45\\
  60.     \>HI=LOC\\
  61.     \>I=I-1\;
  62. >CALL FIND%(IDS,NEW,LOC)%---%50>CONTINUE\\
  63.     \C IF .NOT.NEW%---%40>CONTINUE\-XOR-\
  64.     \C ELSE"50\;
  65. C IF .NOT.NEW%---%40>CONTINUE\\
  66.     \>IF(NEW)GOTO 40\\
  67.     \>MATRIX(HI,J)=LOC\\
  68.     \>GOTO 50\;
  69. C ELSE"50\\
  70.     \>I=I+1\\
  71.     \>ID(I)=IDS\\
  72.     \>CALL INIT(I)\\
  73.     \>MATRIX(HI,J)=I\\
  74.     \>CALL PLACEM%(IDS,I,LOC)\;
  75. C SCAN FOR ANCESTOR SETS AND MARK THEM\\
  76.     \>READ(5,115,end=110) ID(IMAX+I),I=1,19%---%110>continue\\
  77.     \>J=0\\
  78.     \C MARK EACH PARENT SET IN TURN\\
  79.     \C DO WHILE ID(IMAX+J+1).NOT.STARS%---%410>CONTINUE\\
  80.     \>JMAX=J\\
  81.     \>DO 510 I=1,IMAX%---%510>CONTINUE\;
  82. >READ(5,115,end=110) ID(IMAX+I),I=1,19%---%110>continue\\
  83.     \115>FORMAT(19A8)\;
  84. >DO 510 I=1,IMAX%---%510>CONTINUE\\
  85.     \>IF(MARK%(RP,20))\\
  86.     \><WRITE(7,375) ID(RP),ID(MATRIX(RP,IMOM)),ID(MATRIX(RP,IPOP))\;
  87. C DO WHILE ID(IMAX+J+1).NOT.STARS%---%410>CONTINUE\\
  88.     \>IF(ID(IMAX+J+1).EQ.'********') GOTO 410\\
  89.     \>J=J+1\\
  90.     \C TRAVERSE ANCESTOR TREE AND MARK ALL INDIVIDUALS REACHED\\
  91.     \>IDS=ID(IMAX+J)\\
  92.     \>SP=1\\
  93.     \>WRITE(6,180) I\\
  94.     \>CALL FIND(IDS,NEW,LOC)\\
  95.     \>S(SP)=LOC\\
  96.     \C IF(NEW)%---%299>CONTINUE\\
  97.     \C DO WHILE SP>0%---%400>CONTINUE\;
  98. C IF(NEW)%---%299>CONTINUE\\
  99.     \>WRITE(6,298) I\\
  100.     \298>FORMAT(' ',A8,' NOT FOUND IN INPUT SET.')\\
  101.     \>GOTO 400\;
  102. >WRITE(6,180) I\\
  103.     \180>FORMAT%(' DEPTH-FIRST ANCESTOR TREE TRAVERSAL - ITEM',I3,'.')\;
  104. C SCAN THE MARK VECTORS AND OUTPUT COUNTS\\
  105.     \>DO 195 I=1,JMAX\\
  106.     \195>S(I)=0\\
  107.     \>DO 200 I=1,IMAX%---%200>CONTINUE\\
  108.     \>WRITE(6,280)%(I,S(I)), I=1,JMAX\;
  109. >WRITE(6,280)%(I,S(I)), I=1,JMAX\\
  110.     \280>FORMAT%(' # OF OCCURENCES OF A PROGENITOR WITH N DESCENDANTS',\;
  111. 280>FORMAT%(' # OF OCCURENCES OF A PROGENITOR WITH N DESCENDANTS',\\
  112.     \><' IN THE REQUESTED SET AS N : #'/\\
  113.     \><19(I2,':',13)\;
  114. >DO 200 I=1,IMAX%---%200>CONTINUE\\
  115.     \>COUNT=0\\
  116.     \>DO 210 J=1,JMAX%---%210>CONTINUE\\
  117.     \>S(COUNT)=S(COUNT)+1\;
  118. >DO 210 J=1,JMAX%---%210>CONTINUE\\
  119.     \>IF(MARK(I,J)) COUNT=COUNT+1\;
  120. C SUBROUTINES\\
  121.     \>SUBROUTINE INIT(I)%---%>END\\
  122.     \>SUBROUTINE FIND(IDS,NEW,LOC)%---%>END\\
  123.     \>SUBROUTINE PLACEM(IDS,I,ORP)%---%>END\;
  124. >SUBROUTINE INIT(I)%---%>END\\
  125.     \C INIT NEW MATRIX ELEMENT\;
  126. C INIT NEW MATRIX ELEMENT\\
  127.     \>CHARACTER*8 %ID(1200)\\
  128.     \>INTEGER*2 MATRIX(1200,4),I\\
  129.     \>INTEGER*2 IMOM,IPOP,ILEFT,IRIGHT\\
  130.     \>LOGICAL*1 %MARK(1200,2000)\\
  131.     \>COMMON ID,MATRIX,MARK,IMOM,IPOP,ILEFT,IRIGHT\\
  132.     \C ACTUAL VALUES INITIALIZATION\;
  133. C ACTUAL VALUES INITIALIZATION\\
  134.     \>DO 600 J=1,20\\
  135.     \600>MARK(I,J)=.FALSE.\\
  136.     \>MATRIX(I,ILEFT)=0\\
  137.     \>MATRIX(I,IRIGHT)=0\\
  138.     \>MATRIX(I,IPOP)=0\\
  139.     \>MATRIX(I,IMOM)=0\\
  140.     \>RETURN\;
  141. C DO WHILE SP>0%---%400>CONTINUE\\
  142.     \300>IF(SP.EQ.0)GOTO 400%---%>GOTO 300\\
  143.     \370>FORMAT(' ',3A8)\\
  144.     \375>FORMAT(3A8)\;
  145. 300>IF(SP.EQ.0)GOTO 400%---%>GOTO 300\\
  146.     \>RP=S(SP)\\
  147.     \>SP=SP-1\\
  148.     \C IF NEW TERRITORY AND IMOM NE 0 THEN%---%350>CONTINUE\\
  149.     \C IF NEW TERRITORY AND IPOP NE 0 THEN%---%360>CONTINUE\\
  150.     \>MARK(RP,I)=%.TRUE.\\
  151.     \>MARK(RP,20)=%.TRUE.\;
  152. C IF NEW TERRITORY AND IMOM NE 0 THEN%---%350>CONTINUE\\
  153.     \>IF(MATRIX(RP,IMOM).EQ.0.OR.MARK(RP,I))GOTO 350\\
  154.     \>WRITE(6,370) ID(RP),ID(MATRIX(RP,IMOM)),ID(MATRIX(RP,IPOP))\\
  155.     \>SP=SP+1\\
  156.     \>S(SP)=MATRIX%(RP,IMOM)\;
  157. C IF NEW TERRITORY AND IPOP NE 0 THEN%---%360>CONTINUE\\
  158.     \>IF(MATRIX(RP,IPOP).EQ.0.OR.MARK(RP,I))GOTO 360\\
  159.     \>SP=SP+1\\
  160.     \>S(SP)=MATRIX%(RP,IPOP)\;
  161. >SUBROUTINE PLACEM(IDS,I,ORP)%---%>END\\
  162.     \C PUT INDIVIDUAL IN BINARY TREE ACCORDING TO ITS LEXICAL VALUE\\
  163.     \C DECLARATIONS"161\\
  164.     \>IF(IDS.LT.%ID(ORP))MATRIX%(ORP,ILEFT)=I\\
  165.     \>IF(IDS.GT.%ID(ORP))MATRIX%(ORP,IRIGHT)=I\\
  166.     \>RETURN\;
  167. C DECLARATIONS"161\\
  168.     \>CHARACTER*8 IDS,ID(1200)\\
  169.     \>INTEGER*2 MATRIX(1200,4),ORP,I\\
  170.     \>INTEGER*2 IMOM,IPOP,ILEFT,IRIGHT\\
  171.     \>LOGICAL*1 %MARK(1200,2000)\\
  172.     \>COMMON ID,MATRIX,MARK,IMOM,IPOP,ILEFT,IRIGHT\;
  173. >SUBROUTINE FIND(IDS,NEW,LOC)%---%>END\\
  174.     \C LOCATE THE RECORD NUMBER OF THE INDIVIDUAL PASSED AS ARGUMENT\\
  175.     \C DECLARATIONS"154\\
  176.     \>NEW=.FALSE.\\
  177.     \>RP=1\\
  178.     \C DO WHILE RP.NE.0%---%890>CONTINUE\\
  179.     \>NEW=.TRUE.\\
  180.     \>LOC=ORP\\
  181.     \>RETURN\;
  182. C DECLARATIONS"154\\
  183.     \>CHARACTER*8 IDS,ID(1200)\\
  184.     \>INTEGER*2 MATRIX(1200,4),LOC,RP,ORP\\
  185.     \>INTEGER*2 IMOM,IPOP,ILEFT,IRIGHT\\
  186.     \>LOGICAL*1 NEW,MARK(1200,2000)\\
  187.     \>COMMON ID,MATRIX,MARK,IMOM,IPOP,ILEFT,IRIGHT\;
  188. C DO WHILE RP.NE.0%---%890>CONTINUE\\
  189.     \800>IF(RP.EQ.0)GOTO 890%---%>GOTO 800\;
  190. 800>IF(RP.EQ.0)GOTO 890%---%>GOTO 800\\
  191.     \>ORP=RP\\
  192.     \C CASE IDS VS. ID(RP)%---%880>CONTINUE\;
  193. C CASE IDS VS. ID(RP)%---%880>CONTINUE\\
  194.     \C IF IDS.LT.%ID(RP) GO LEFT%---%810>CONTINUE\-XOR-\
  195.     \C IF IDS.GT.%ID(RP) GO RIGHT%---%820>CONTINUE\-XOR-\
  196.     \C FOUND SOUGHT ITEM, RETURN HIS SPOT\;
  197. C IF IDS.LT.ID(RP) GO LEFT%---%810>CONTINUE\\
  198.     \>IF(IDS.GE.%ID(RP))GOTO 810\\
  199.     \>RP=MATRIX(RP,ILEFT)\\
  200.     \>GOTO 880\;
  201. C IF IDS.GT.ID(RP) GO RIGHT%---%820>CONTINUE\\
  202.     \>IF(IDS.LE.%ID(RP))GOTO 820\\
  203.     \>RP=MATRIX(RP,IRIGHT)\\
  204.     \>GOTO 880\;
  205. C FOUND SOUGHT ITEM, RETURN HIS SPOT\\
  206.     \>LOC=RP\\
  207.     \>RETURN\;
  208. ENDWARNIERDIAGRAM
  209. c@e`gÇiák└mαoq s@u`wÇyá{└}αü â@à`çÇëáï└ìα     æ     ô@    ò`    ùÇ    Öá    ¢└    ¥α    ƒ
  210. í 
  211. ú@
  212. Ñ`
  213. ºÇ
  214. ⌐á
  215. ½└
  216. ¡α
  217.   ▒  │@  o ╖Ç ╣á ╗└ ╜α ┐ ┴  ├@ ┼` ╟Ç ╔á ╦└ ═α ╧╤ ╙@╒`╫Ç┘á█└▌α▀ß π@σ`τÇΘ≡ δ≡  ∩∩ /≤@⌡`≈Ç∙á√└²α !Aaü    í ┴ß!Aaüí┴ß!!#A%a'ü)í+┴-ß/1!3A5a ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷ECHO OFF
  218. CLS
  219. TYPE GO.TXT
  220. ECHO ON
  221. └α! #@%`'Ç »+└-α/1 3@5`7Ç9á;└=α?A C@E`GÇIáK└MαOQ S@U`WÇYá[└]α_a c@e`gÇiák└mαoq s@u`wÇyá{└}αü â@à`çÇëáï└ìαÅ    æ     ô@    ò`    ùÇ    Öá    ¢└    ¥α    ƒ
  222. í 
  223. ú@
  224. Ñ`
  225. ºÇ
  226. ⌐á
  227. ½└
  228. ¡α
  229. » ▒   O ╡` ╖Ç ╣á ╗└ ╜α ┐ ┴  ├@ ┼` ╟Ç ╔á ╦└ ═α ╧╤ ╙@╒`╫Ç┘á█└▌α▀ß π@σ` ÅΘáδ└φα∩± ≤@⌡`≈Ç∙á√└²α !Aaü    í ┴ß!Aaüí┴ß!!#A%a'ü)í   -ß/1!3± 5a7ü9± ;┴   ?±  /    ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷